home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BMUG Revelations
/
BMUG Revelations.toast
/
Programming
/
Programming Languages
/
Yerk 3.64
/
Toolbox Classes
/
Ctl
< prev
next >
Wrap
Text File
|
1993-06-17
|
5KB
|
164 lines
\ 4/16/84 NDI Version 1.0
\ 5/07/84 NDI Convert to CALL:
\ 6/22/84 NDI add INIT:, change new, modify struct
\ 8/19/84 CBD added FindCtl
\ 12/16/84 cbd VsCtl is separate from Control
\ 1/31/87 rfl added myWindow and myValue; new: window: put: get: classinit:
\ 6/02/87 rfl changed width of rect to 20+ in x from 17+
\ 1/19/88 rfl added getnew settitle gettitle
\ 9/01/88 rfl changed back to 17 and added dim: undim:
\ 9/11/88 rfl dim: to disable, undim: to enable:
\ 12/14/90 rfl removed initfont in new: and getnew: and added saveFont, restFont
\ 12/18/91 rfl resID now IVAR..getnew requires nothing on stack. must window: first
\ 6/24/92 rfl putwindow and getwindow methods added for consistency to other code
\ 8/09/92 rfl added frame: to draw default frame around the control
\ 5/13/93 rfl protected getnew:
\ 6/17/93 rfl added offset:
Decimal
0 variable fontBuf 4 allot
: savefont ( wind -- ) 68 + fontBuf 8 cmove ;
: restfont ( wind -- ) fontBuf swap 68 + 8 cmove ;
\ ( ctlhndl -- objptr ) get rel ptr to ctl obj from ctl rec
: Get-ctl-obj 0 swap call GetCRefCon ;
\ ( objptr ctlhndl -- ) set rel ptr to ctl obj in ctl rec
: Set-ctl-obj swap call SetCRefCon ;
\ ( addr len -- width ) return width of string in current font
: tWidth str255 >R word0 R> call StringWidth word0 ;
0 constant buttonID \ control types
1 constant checkID
2 constant radioID
16 constant VsID
\ basic control class for simple controls - buttons, etc.
:CLASS Control <Super Object
Int procid
Handle ctlHndl
Var action
Int myValue
Var myWindow
Int resID
\ ( n -- )
:M PUTRESID: put: resID ;M
\ ( part# -- ) perform action for control
:M EXEC: IF exec: action THEN ;M
\ ( -- l t r b ) stack bounds rectangle
:M GETRECT: ptr: ctlhndl 8+ get: rect ;M
\ ( -- ) cause the control to be drawn
:M UPDATE: Ptr: CtlHndl 8+ +base call InvalRect ;M
:M HIDE: Get: Ctlhndl call HideControl ;M
:M SHOW: Get: Ctlhndl call ShowControl ;M
\ ( x y -- ) Move control to x,y location
:M MOVETO: pack get: ctlhndl swap call MoveControl ;M
\ ( dx dy -- ) Offset from current x,y by dx,dy
:M OFFSET: { dx dy \ x y -- } getRect: self 2drop -> y -> x
dx x + dy y + moveto: self ;M
\ ( w h -- ) set width, height of control's rect
:M SIZE: pack get: ctlhndl swap call SizeControl ;M
\ ( procid -- ) initialize
:M INIT: put: procid ;M
\ ( window -- ) use this to initialize the owning window
:M WINDOW: put: myWindow ;M
:M PUTWINDOW: put: myWindow ;M
:M GETWINDOW: get: myWindow ;M
\ ( cfa -- ) set the action for this control
:M ACTIONS: put: action ;M
\ ( value -- ) set ctl value
:M PUT: { theVal -- } alive: [ obj: myWindow ]
IF theVal get: ctlhndl swap makeint call SetCtlValue THEN
theVal put: myValue ;M
\ ( -- val) some ctls may need original value, eg scroll bar
:M GET: alive: [ obj: myWindow ]
IF w 0 get: ctlhndl call getCtlValue word0
ELSE get: myValue
THEN ;M
\ build a control on the heap
:M NEW: { x y addr len theWind \ tWid -- }
theWind saveFont
get: procID 8 and 0= \ window font if true
IF 0 tFont 12 tSize THEN addr len tWidth -> tWid \ width of title
x y x tWid + 17 + y 17 + put: tempRect
0 abs: theWind Abs: tempRect addr len str255
w 256 word0 word0 w 1 Int: procid ^base
call NewControl put: ctlhndl
^base get: ctlhndl set-ctl-obj
theWind put: myWindow get: myValue put: self theWind restFont ;M
:M getnew: { \ theWind -- } get: myWindow -> theWind
theWind 0= classerr" 157 theWind saveFont
0 int: resID theWind +base call getNewControl dup 0= classerr" 170
put: ctlhndl
^base get: ctlhndl set-ctl-obj
theWind put: myWindow get: myValue put: self theWind restFont ;M
\ ( -- ctlhndl )
:M HANDLE: Get: CtlHndl ;M
\ ( hiliteState -- ) Hilite a part or entire control
:M HILITE: get: ctlhndl swap makeInt
call HiliteControl ;M
:M DISABLE: -1 hilite: self ;M
:M ENABLE: 0 hilite: self ;M
\ draws a border around a control to signify the default button.
:M FRAME: pushPort set: [ obj: myWindow ] 3 3 pack call PenSize
getRect: self put: tempRect
-4 -4 inset: tempRect
abs: tempRect 16 16 pack call FrameRoundRect call penNormal popPort ;M
\ ( addr len -- )
:M setTitle: str255 get: ctlhndl swap call setCTitle ;M
\ ( -- addr len )
:M getTitle: get: ctlhndl pad +base call getCTitle pad count ;M
\ ( -- )
:M CLOSE: Get: Ctlhndl call DisposControl ;M
\ ( -- ) set default control to a standard button
:M CLASSINIT: buttonID init: self 'c null actions: self ;M
\ ( ^wind -- ) show an example button
:M EXAMPLE: { thewind -- } 200 100 " Button"
theWind new: self update: self ;M
;CLASS
0 variable theCtl
\ control part codes
10 constant inButton \ simple button
11 constant inCheckBox \ check or radio
129 constant inThumb
20 constant inUpButton \ up arrow in scroll bar
21 constant inDownButton \ down arrow
22 constant inPageUp
23 constant inPageDown
\ add to ID if title in application font
8 constant useWFont